Celestin Apprentice 7/Apprentice-Release7.iso/Environments/PowerLisp 2.01/PowerLisp 2.01 ƒ/Library/assembler_ppc.lisp

Text File | 1996-05-17 | 22.0 KB | 818 lines | [TEXT/ROSA]

;;;
;;;        PowerLisp 2.0
;;;        Copyright © 1996 Roger Corman.  All rights reserved.
;;;        PowerPC Assembler source
;;;

;
;    Source code for assembler.
;

(eval-when (:compile-toplevel :load-toplevel :execute)
    (provide :assembler)
    (in-package :assembler))

(eval-when (:compile-toplevel :load-toplevel :execute)
(export
'(
    r0  r1  r2  r3  r4  r5  r6  r7
    r8  r9  r10  r11 r12 r13 r14 r15
    r16 r17 r18  r19 r20 r21 r22 r23
    r24 r25 r26  r27 r28 r29 r30 r31 sp rtoc
    fp0  fp1  fp2   fp3  fp4  fp5  fp6  fp7
    fp8  fp9  fp10  fp11 fp12 fp13 fp14 fp15
    fp16 fp17 fp18  fp19 fp20 fp21 fp22 fp23
    fp24 fp25 fp26  fp27 fp28 fp29 fp30 fp31
    registers
    float-registers
    $CAR
    $CDR
    $SETCAR
    $SETCDR
    $SYMBOL-VALUE
    $SYMBOL-PLIST
    $CONSP
    $INTEGER
    $RETURN
    $FUNC-BEGIN
    $IF
    $IFELSE
    $LOAD-OBJ
    $LOAD-LONG
    $CALL
    $REFERENCE
    dc.l
    blr
    b
    bl
    bla
    bc
    bne
    beq
    blt
    mr
    stw
    stwu
    lwz
    lbz
    lbzu
    addi
    addis
    add
    or_
    ori
    oris
    li
    lis
    cmpwi
    cmpw
    mtlr
    mflr
    stmw
    lmw
    lwzu
    sraw
    sraw.
    andi.
    lfd
    mtctr
    bctr
    bctrl
)))

(defconstant r0 0)
(defconstant r1 1)
(defconstant r2 2)
(defconstant r3 3)
(defconstant r4 4)
(defconstant r5 5)
(defconstant r6 6)
(defconstant r7 7)
(defconstant r8 8)
(defconstant r9 9)
(defconstant r10 10)
(defconstant r11 11)
(defconstant r12 12)
(defconstant r13 13)
(defconstant r14 14)
(defconstant r15 15)
(defconstant r16 16)
(defconstant r17 17)
(defconstant r18 18)
(defconstant r19 19)
(defconstant r20 20)
(defconstant r21 21)
(defconstant r22 22)
(defconstant r23 23)
(defconstant r24 24)
(defconstant r25 25)
(defconstant r26 26)
(defconstant r27 27)
(defconstant r28 28)
(defconstant r29 29)
(defconstant r30 30)
(defconstant r31 31)

(defconstant fp0 0)
(defconstant fp1 1)
(defconstant fp2 2)
(defconstant fp3 3)
(defconstant fp4 4)
(defconstant fp5 5)
(defconstant fp6 6)
(defconstant fp7 7)
(defconstant fp8 8)
(defconstant fp9 9)
(defconstant fp10 10)
(defconstant fp11 11)
(defconstant fp12 12)
(defconstant fp13 13)
(defconstant fp14 14)
(defconstant fp15 15)
(defconstant fp16 16)
(defconstant fp17 17)
(defconstant fp18 18)
(defconstant fp19 19)
(defconstant fp20 20)
(defconstant fp21 21)
(defconstant fp22 22)
(defconstant fp23 23)
(defconstant fp24 24)
(defconstant fp25 25)
(defconstant fp26 26)
(defconstant fp27 27)
(defconstant fp28 28)
(defconstant fp29 29)
(defconstant fp30 30)
(defconstant fp31 31)

(defconstant registers
   '(r0  r1  r2  r3  r4  r5  r6  r7
     r8  r9  r10  r11 r12 r13 r14 r15
     r16 r17 r18  r19 r20 r21 r22 r23
     r24 r25 r26  r27 r28 r29 r30 r31 sp rtoc))

(defconstant sp r1)
(defconstant rtoc r2)

(defconstant float-registers
    '(fp0  fp1  fp2   fp3  fp4  fp5  fp6  fp7
      fp8  fp9  fp10  fp11 fp12 fp13 fp14 fp15
      fp16 fp17 fp18  fp19 fp20 fp21 fp22 fp23
      fp24 fp25 fp26  fp27 fp28 fp29 fp30 fp31))


;;    Macros to access SYMBOL and NODE fields.
;;    These are dependent on the symbol class definition.
;;    The C++ source is in LispObjects.h.

(defconstant *symbol-value-offset*                 8)
(defconstant *symbol-plist-offset*                 12)
(defconstant *symbol-package-offset*             16)
(defconstant *symbol-name-offset*                 20)
(defconstant *symbol-flags-offset*                 24)
(defconstant *symbol-jump-table-entry-offset*     26)
(defconstant *symbol-jump-address-offset*         28)
(defconstant *symbol-function-offset*             32)

(defconstant *node-car-offset*                    0)
(defconstant *node-cdr-offset*                    4)
(defconstant *node-flags-offset*                8)
(defconstant *node-type-offset*                    9)

(defvar *assembler-address*    0)
(defvar *assembler-references*    nil)

;
;    We do an eval-when on the entire file so that we get the
;    performance benefits immediately
;
(eval-when (:compile-toplevel :load-toplevel :execute)

(defmacro $CAR (node &optional dest-reg)
    (unless dest-reg (setq dest-reg node))
    `(
        (lwz ,dest-reg (,node ,*node-car-offset*))
     ))

(defmacro $CDR (node &optional dest-reg)
    (unless dest-reg (setq dest-reg node))
    `(
        (lwz ,dest-reg (,node ,*node-cdr-offset*))
     ))

(defmacro $SETCAR (node value)
    `(
        (stw ,value (,node ,*node-car-offset*))
     ))

(defmacro $SETCDR (node value)
    `(
        (stw ,value (,node ,*node-cdr-offset*))
     ))

(defmacro $SYMBOL-VALUE (node)
    `(
        (lwz ,node (,node))        ;; get symbol object
        (lwz ,node (,node ,*symbol-value-offset*))    ;; get value cons
        (lwz ,node (,node))        ;; value in car field
     ))

(defmacro $SYMBOL-PLIST (node)
    `(
        (lwz ,node (,node))        ;; get symbol object
        (lwz ,node (,node ,*symbol-plist-offset*))
     ))

(defmacro $CONSP (node)
    `(
        ($IF
        ((andi. r0 ,node 1))        ; (if (not (integerp node)) ...
        ((lbz ,node (,node ,*node-type-offset*))
        (cmpwi r0 0)))
    ))

(defmacro $INTEGER (node &optional dest-reg)
    (unless dest-reg (setq dest-reg node))
    `(
        (sraw ,node ,node 1)        ;; shift right one bit to find integer
     ))


;;
;;    The $RETURN macro zeros out the multiple value cell, stores
;;    the passed value in r3 (to return it), and unlinks the stack frame.
;;
(defmacro $RETURN (retval stacksize)
    (if (eq retval 'r3)
        `(
            ($LOAD-LONG r5 cl::%multiple-values-address)
            (li r4 0)
            (stw r4 (r5))
            (addi sp sp ,stacksize)
            (lwz r0 (sp 8))
            (mtlr r0)
            (blr)
         )
        `(
            (mr r3 ,retval)
            ($LOAD-LONG r5 cl::%multiple-values-address)
            (li r4 0)
            (stw r4 (r5))
            (addi sp sp ,stacksize)
            (lwz r0 (sp 8))
            (mtlr r0)
            (blr)
         )))

;;
;;    The $FUNC-BEGIN macro sets up the A6 stack frame link,
;;    and stores a pointer to the parameter block in A0.
;;    Usage:
;;        ($FUNC-BEGIN 4)        ;; allocates 4 bytes (space for one object)
;;                            ;; on the stack
;;
(defmacro $FUNC-BEGIN (size)
    `(
        (mflr r0)
        (stw r0 (sp 8))
;        (lwz rtoc (sp 20))    ;; don't need this anymore
        (stwu sp (sp ,(- size)))
     ))

;;
;;    $IF macro
;;    Usage:
;;        ($IF
;;            (cmpwi r7 0)         ;; if r7 == 0 the next statement will be executed
;;            (
;;                (mr r0 r3)
;;            ))
;;
(defmacro $IF (condition instructions)
    (let ((temp-label (gensym)))
        ;;    allow single instruction clauses or lists of instructions
        (if (not (listp (car condition)))
            (setq condition (list condition)))
        (if (not (listp (car instructions)))
            (setq instructions (list instructions)))

        `(
            ,@condition
            (bne ,temp-label)
            ,@instructions
            ,temp-label
         )))

;;
;;    $IFELSE macro
;;    Usage:
;;        ($IFELSE
;;            (cmpwi r7 0)         ;; if r7 == 0 the next instruction will be executed
;;            (
;;                (mr r0 r3)
;;            )
;;            (
;;                (mr r2 r3)    ;; otherwise this instruction will be executed
;;            ))
;;
(defmacro $IFELSE (condition if-instructions else-instructions)
    (let ((else-label (gensym))
          (exit-label (gensym)))

        ;;    allow single instruction clauses or lists of instructions
        (if (not (listp (car condition)))
            (setq condition (list condition)))
        (if (not (listp (car if-instructions)))
            (setq if-instructions (list if-instructions)))
        (if (not (listp (car else-instructions)))
            (setq else-instructions (list else-instructions)))

        `(
            ,@condition
            (bne ,else-label)
            ,@if-instructions
            (b ,exit-label)
            ,else-label
            ,@else-instructions
            ,exit-label
         )))

(defmacro $LOAD-OBJ (reg obj)
    (let ((exec (eval obj)))
        (add-reference obj)
        `((lis ,reg ,(ash (address exec) -16))
          (ori ,reg ,reg ,(mod (address exec) #x10000)))))

(defmacro $LOAD-LONG (reg n)
    (if (symbolp n)
        (progn
            (add-reference `(symbol-value ,n))
            (setq n (symbol-value n))))
    `((lis ,reg ,(ash n -16))
      (ori ,reg ,reg ,(mod n #x10000))))

(defmacro $CALL (func)
;;    `((bla ,func))
    (if (or (not (consp func))
            (not (consp (cdr func)))
            (not (eq (car func) 'function)))
        (error "Invalid call form: ~A" func))

    (add-reference func)
    (let ((xaddr (exec-address (cadr func))))

        `((lis r26 ,(cl::%fixnum-upper16 xaddr))
            (ori r26 r26 ,(cl::%fixnum-lower16 xaddr))
          (mtctr r26)
          (bctrl))))

;;
;;    The $REFERENCE macro does not generate any instructions, but
;;    is used by the compiler as a flag to the assembler to correctly
;;    generate address reference entries when code is compiled to a file.
;;
(defmacro $REFERENCE (referenced-item)
    nil)

(defun check-source-reg-or-0 (source)
    (if (not (or (member source registers) (zerop source)))
        (error "Invalid source. source: ~A" source))
    (if (not (and (integerp source) (zerop source))) (symbol-value source) source))

(defun check-source-reg (source)
    (if (not (member source registers))
        (error "Invalid source. source: ~A" source))
    (symbol-value source))

(defun check-reg (r)
    (if (not (member r registers))
        (error "Invalid register. register: ~A" r))
    (symbol-value r))

(defun check-float-reg (r)
    (if (not (member r float-registers))
        (error "Invalid floating point register. register: ~A" r))
    (symbol-value r))

(defun check-dest-reg-or-0 (dest)
    (if (not (or (member dest registers) (zerop dest)))
        (error "Invalid destination. destination: ~A" dest))
    (if (symbolp dest) (symbol-value dest) dest))

(defun check-dest-reg (dest)
    (if (not (member dest registers))
        (error "Invalid destination. destination: ~A" dest))
    (symbol-value dest))

(defun format-sreg-dreg-u16 (instruction code sreg dreg uimm)
    (setq sreg (check-source-reg sreg))
    (setq dreg (check-dest-reg dreg))
    (if (> (integer-length uimm) 16)
        (error "Displacement too large.~%Instruction: ~A  Displacement: ~A"
                instruction uimm))
    (+ (ash code 26) (ash sreg 21) (ash dreg 16) (logand uimm #xffff)))

(defun format-sreg-dreg-sreg (instruction code s1 d s2 scode)
    (setq s1 (check-source-reg s1))
    (setq d (check-dest-reg d))
    (setq s2 (check-source-reg s2))
    (+ (ash code 26) (ash s1 21) (ash d 16) (ash s2 11) scode))

(defun format-sreg-dreg-imm (instruction code s d imm scode)
    (setq s (check-source-reg s))
    (setq d (check-dest-reg d))
    (+ (ash code 26) (ash s 21) (ash d 16) (ash imm 11) scode))

(defun format-fdreg-sreg-disp (instruction code fdreg sreg disp)
    (setq fdreg (check-float-reg fdreg))
    (setq sreg (check-source-reg sreg))
    (if (> (integer-length disp) 16)
        (error "Displacement too large.~%Instruction: ~A  Displacement: ~A"
                instruction disp))
    (+ (ash code 26) (ash fdreg 21) (ash sreg 16) (logand disp #xffff)))


(defmacro dc.l (w)
    (cond
        ((symbolp w)
         (add-reference `(symbol-value ,w))
         (list (symbol-value w)))
        (t (list w))))

(defmacro blr ()   (list #x4E800020))
(defmacro bctr ()  (list #x4E800420))
(defmacro bctrl () (list #x4E800421))

(defmacro b (dst)
    (if (symbolp dst)
        (return (list (ash 18 26) dst)))
    (if (consp dst)
        (if (eq (car dst) 'function)
            (let ((instruction 0)
                  (addr (exec-address (cadr dst))))
                (add-reference dst)
                (setq instruction (+ (ash 18 26) addr))
                (return (list instruction)))
        ;; else
            (error "Invalid destination.~%Instruction: bla  Destination: ~A" dst)))
    (let ((instruction 0))
        (add-reference dst)
        (setq instruction (+ (ash 18 26) dst))
        (list instruction)))

(defmacro bl (dst)
    (if (symbolp dst)
        (return (list (+ (ash 18 26) 1) dst)))
    (if (consp dst)
        (if (eq (car dst) 'function)
            (let ((instruction 0)
                  (addr (exec-address (cadr dst))))
                (add-reference dst)
                (setq instruction (+ (ash 18 26) addr 1))
                (return (list instruction)))
        ;; else
            (error "Invalid destination.~%Instruction: bla  Destination: ~A" dst)))
    (let ((instruction 0))
;        (add-reference dst)
        (setq instruction (+ (ash 18 26) dst 1))
        (list instruction)))

(defmacro bc (bo bi dst)
    (if (symbolp dst)
        (return
            (list (+ (ash 16 26) (ash bo 21) (ash bi 16)) dst)))
    (if (consp dst)
        (if (eq (car dst) 'function)
            (let ((instruction 0)
                  (addr (exec-address (cadr dst))))
                (add-reference dst)
                (setq instruction
                    (+ (ash 16 26) (ash bo 21) (ash bi 16) addr))
                (return (list instruction)))
        ;; else
            (error "Invalid destination.~%Instruction: bla  Destination: ~A" dst)))
    (let ((instruction 0))
        (add-reference dst)
        (setq instruction
            (+ (ash 16 26) (ash bo 21) (ash bi 16) dst))
        (list instruction)))

(defmacro bne (dst) `((bc  4 2 ,dst)))
(defmacro blt (dst) `((bc 12 0 ,dst)))
(defmacro beq (dst) `((bc 12 2 ,dst)))

(defmacro bla (dst)
    (if (symbolp dst)
        (progn
            (add-reference `(symbol-value ,dst))
            (setq dst (symbol-value dst))))
    (if (consp dst)
        (if (eq (car dst) 'function)
            (let ((instruction 0)
                  (addr (exec-address (cadr dst))))
                (add-reference dst)
                (setq addr (logior addr 3))        ; set lower 2 bits
                (setq instruction (+ (ash 18 26) addr))
                (return (list instruction)))
        ;; else
            (error "Invalid destination.~%Instruction: bla  Destination: ~A" dst)))
    (let ((instruction 0))
        (add-reference dst)
        (setq instruction (+ (ash 18 26) dst))
        (setq instruction (logior instruction 3))    ; set lower 2 bits
        (list instruction)))

(defmacro mr (dst src) `((or_ ,dst ,src ,src)))

(defmacro stw (src dst)
    (if (not (consp dst))
        (error "Invalid destination.~%Instruction: stw  Destination: ~A" dst))
    (let ((displacement (if (cdr dst) (cadr dst) 0))
          (dest-value (check-dest-reg-or-0 (car dst))))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: stw  Displacement: ~A" displacement))
        (list (+ (ash 36 26)
                (ash (symbol-value src) 21)
                (ash dest-value 16)
                (logand displacement #xffff)))))

(defmacro stmw (src dst)
    (if (not (consp dst))
        (error "Invalid destination.~%Instruction: stmw  Destination: ~A" dst))
    (let ((displacement (if (cdr dst) (cadr dst) 0))
          (dest-value (check-dest-reg-or-0 (car dst))))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: stmw  Displacement: ~A" displacement))
        (list (+ (ash 47 26)
                (ash (symbol-value src) 21)
                (ash dest-value 16)
                (logand displacement #xffff)))))

(defmacro stwu (src dst)
    (if (not (consp dst))
        (error "Invalid destination.~%Instruction: stwu  Destination: ~A" dst))
    (let ((displacement (if (cdr dst) (cadr dst) 0)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: stwu  Displacement: ~A" displacement))
        (list (+ (ash 37 26)
                (ash (symbol-value src) 21)
                (ash (symbol-value (car dst)) 16)
                (logand displacement #xffff)))))

(defmacro lwz (dst src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lwz  Source: ~A" src))
    (let ((displacement (if (cdr src) (cadr src) 0))
          (source (car src)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: lwz  Displacement: ~A" displacement))
        (setq source (check-source-reg-or-0 source))
        (list (+ (ash 32 26)
                (ash (symbol-value dst) 21)
                (ash source 16)
                (logand displacement #xffff)))))

(defmacro lmw (dst src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lmw  Source: ~A" src))
    (let ((displacement (if (cdr src) (cadr src) 0))
          (source (car src)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: lmw  Displacement: ~A" displacement))
        (setq source (check-source-reg-or-0 source))
        (list (+ (ash 46 26)
                (ash (symbol-value dst) 21)
                (ash source 16)
                (logand displacement #xffff)))))

(defmacro lwzu (dst src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lwzu  Source: ~A" src))
    (let ((displacement (if (cdr src) (cadr src) 0))
          (source (car src)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: lwzu  Displacement: ~A" displacement))
        (setq source (check-source-reg-or-0 source))
        (if (zerop source)
            (error "Source cannot be zero for this instruction~%Instruction: lwzu  Source: ~A" src))
        (list (+ (ash 33 26)
                (ash (symbol-value dst) 21)
                (ash source 16)
                (logand displacement #xffff)))))

(defmacro lbz (dst src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lbz  Destination: ~A" src))
    (let ((displacement (if (cdr src) (cadr src) 0))
            (source (car src)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: lwz  Displacement: ~A" displacement))
        (setq source (check-source-reg-or-0 source))
        (list (+ (ash 34 26)
                (ash (symbol-value dst) 21)
                (ash source 16)
                (logand displacement #xffff)))))

(defmacro lbzu (dst src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lbzu  Destination: ~A" src))
    (let ((displacement (if (cdr src) (cadr src) 0))
            (source (car src)))
        (if (> (integer-length displacement) 15)
            (error "Displacement too large.~%Instruction: lwz  Displacement: ~A" displacement))
        (setq source (check-source-reg-or-0 source))
        (list (+ (ash 35 26)
                (ash (symbol-value dst) 21)
                (ash source 16)
                (logand displacement #xffff)))))

(defmacro addi (dst src disp)
    (if (> (integer-length disp) 16)
        (error "Displacement too large.~%Instruction: addi  Displacement: ~A" disp))
    (setq src (check-source-reg-or-0 src))
    (list (+ (ash 14 26)
            (ash (symbol-value dst) 21)
            (ash src 16)
            (logand disp #xffff))))

(defmacro add (dst src1 src2)
    (list (+ (ash 31 26)
            (ash (symbol-value dst) 21)
            (ash (symbol-value src1) 16)
            (ash (symbol-value src2) 11)
            (ash 266 1))))

(defmacro addis (dst src disp)
    (if (> (integer-length disp) 16)
        (error "Displacement too large.~%Instruction: addis  Displacement: ~A" disp))
    (setq src (check-source-reg-or-0 src))
    (list (+ (ash 15 26)
            (ash (symbol-value dst) 21)
            (ash src 16)
            (logand disp #xffff))))

(defmacro or_ (dst src1 src2) (list (format-sreg-dreg-sreg 'or_ 31 src1 dst src2 888)))
(defmacro or. (dst src1 src2) (list (format-sreg-dreg-sreg 'or. 31 src1 dst src2 889)))
(defmacro ori (dst src uimm) (list (format-sreg-dreg-u16 'ori 24 src dst uimm)))
(defmacro oris (dst src uimm) (list (format-sreg-dreg-u16 'oris 25 src dst uimm)))
(defmacro li  (dst disp) `((addi  ,dst 0 ,disp)))
(defmacro lis (dst disp) `((addis ,dst 0 ,disp)))
(defmacro sraw (dst src shift) (list (format-sreg-dreg-imm 'sraw 31 src dst shift 1584)))
(defmacro sraw. (dst src shift) (list (format-sreg-dreg-imm 'sraw. 31 src dst shift 1585)))
(defmacro andi. (dest src uimm) (list (format-sreg-dreg-u16 'andi 28 src dest uimm)))

(defmacro lfd (fdest src)
    (if (not (consp src))
        (error "Invalid source.~%Instruction: lfd  Destination: ~A" src))
    (let ((disp (if (cdr src) (cadr src) 0))
            (source (car src)))
        (list (format-fdreg-sreg-disp 'lfd 50 fdest source disp))))

(defmacro cmpwi (dst simm)
    (if (> (integer-length simm) 15)
        (error "Immediate value too large.~%Instruction: addi  Immediate: ~A" simm))
    (list (+ (ash 11 26) (ash (symbol-value dst) 16) (logand simm #xffff))))

(defmacro cmpw (a b)
    (setq a (check-reg a))
    (setq b (check-reg b))
    (list (+ (ash 31 26) (ash a 16) (ash b 11))))

(defmacro mtlr (src)
        (list (+ (ash 31 26) (ash (symbol-value src) 21) (ash 8 16) (ash 467 1))))

(defmacro mflr (dst)
        (list (+ (ash 31 26) (ash (symbol-value dst) 21) (ash 8 16) (ash 339 1))))

(defmacro mtctr (src)
        (list (+ (ash 31 26) (ash (symbol-value src) 21) (ash 9 16) (ash 467 1))))

(defun is-relative-branch-instruction (inst)
    (let ((op (ash inst -26)))
        (or (= op 16) (= op 18))))
(defun merge-address (inst offset)
    (let ((op (ash inst -26)))
        (if (= op 16)            ;; 16-bit offset
            (+ inst (logand offset #xfffc))
            (+ inst (logand offset #x3fffffc)))))

(defun assemble (assembler-instructions references &optional environment)
  (let*
    ((label-table (make-hash-table :test #'eql))
      (newlist nil)
      (codelist nil)
      (*assembler-address* 0)
      (*assembler-references* nil)
      operator)

    (do ((n assembler-instructions (cdr n))
         statement)
        ((null n))
        (setq statement (car n))
        (cond
            ;; if it is a label, add it to the hash table
            ((symbolp statement)
             (setf (gethash statement label-table) *assembler-address*))
            ((consp statement)
             (if (integerp (car statement))     ;; skip address if there is one
                 (setq statement (cdr statement)))

             ;; make sure there is a macro definition
             (setq operator (car statement))
             (unless (symbolp operator)
                 (error "Invalid instruction: ~A" operator))
             (unless (macro-function operator)
                 (error "No definition for instruction: ~A" statement))

             ;; expand the macro one time
             (setq statement (macroexpand-1 statement))

             ;; check for multiple statement result (assembler macro expansion)
             (if (and (consp statement) (not (integerp (car statement))))
                 ;; just splice in the new instructions and continue
                (setq n (append (list nil) statement (cdr n)))
                (if (consp statement)
                    (progn
                        (incf *assembler-address* 4)
                        (push statement newlist)))))

            ;; error if not a symbol or a list
            (t (error "Invalid label encountered: ~A" statement))))

    ;; Now go through and append all the sublists together,
    ;; resolving branch addresses as we go.
    ;; We only currently support 16-bit displacements in the branch
    ;; instructions.

    (setq newlist (reverse newlist))
    (setq *assembler-address* 0)

    (dolist (statement newlist)
        ;; check for branch instructions
        (setq operator (car statement))
        (if (is-relative-branch-instruction operator)
            (if (and (consp (cdr statement))
                    (symbolp (cadr statement)))
                (let* ((sym (cadr statement))
                        (value (gethash sym label-table)))
                    (unless value
                        (error "Label not found: ~A" sym))
                    (unless (integerp value)
                        (error "Invalid label found.~%Label: ~A Value: ~A" sym value))
                    (setf statement
                        (list (merge-address (car statement) (- value *assembler-address*)))))))

        (incf *assembler-address* 4)
        (if statement (push (car statement) codelist)))

    (setq newlist nil)
    (dolist (n codelist)
        (push (mod n #x10000) newlist)
        (push  (ash n -16) newlist))
;;    (let ((*print-base* 16)) (format t "newlist = ~A~%" newlist))
    (%build-function newlist (nreverse *assembler-references*) environment)))

(defun add-reference (ref &optional (offset 0))
    (push
        (cons ref (+ *assembler-address* offset))
        *assembler-references*))

)  ;; close enclosing eval-when form

;;    add defasm to the common lisp package

(eval-when (:compile-toplevel :load-toplevel :execute)
    (in-package :common-lisp)
    (export 'common-lisp::defasm))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro defasm (name lambda-list &rest forms)
;    (declare (unused lambda-list))
    (let ((doc-form nil))
        (if (and (typep (car forms) 'string)
                (cdr forms))
            (progn
                (setq doc-form
                    `((setf (documentation ',name 'function) ,(car forms))))
                (setq forms (cdr forms))))

        `(progn
            ,@doc-form
            (setf (symbol-function ',name) ,(car forms))
            (null-environment (function ,name))
            ',name)))

) ;; close eval-when